;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; package: cl-soap -*-
;;;; ************************************************************************
;;;;
;;;; Code generation for SOAP services described by a wsdl file.
;;;;
;;;; (c) 2007 Utz-Uwe Haus, <lisp@uuhaus.de> All Rights Reserved.
;;;;
;;;; $Id:$
;;;;
;;;; You are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;;
;;;; ************************************************************************


(in-package :cl-soap)

;;;; In an ideal world you could take an WSDL-DOCUMENT-DEFINITIONS object and
;;;; call WSDL-GENERATE-CODE on it to end up with 3 lisp files that implement
;;;; a CLOS binding for the services. Let me known if things work out-of-the-box 
;;;; for you.
;;;; In reality you will encounter namespace problems, wrong wsdl descriptions 
;;;; and schemas, performance problems of your lisp environment and incomplete 
;;;; implementation of the wsdl standard. I'm willing to fix the last of those
;;;; issues.

;;;; We try to be somewhat compatible with the Allegro CL SOAP implementation (>=8.1)


;;; Public part that is user-visible
(defmethod make-client-interface ((conn wsdl-document-definitions) service destination &key 
				  ;; these are as in the ACL SOAP interface:
				  (lisp-package :keyword) (file-package "USER")
				  expand-singleton 
				  (prefix :client-)
				  (suffix :index)
				  (port 0)
				  (compose :hyphen-if-ok)
				  (object-class nil)
				  (action nil)
				  (message-method-prefix nil)
				  (sequence nil)
				  (object-access nil)
				  ;; cl-soap additions
				  (prelude "no user prelude")
				  &allow-other-keys)
  "Generate source code files that allow use of the SOAP service described by CONN.
Required arguments:
  CONN -- the parsed wsdl definition
  SERVICE -- the service to generate code for (nil or 0 for the first service in CONN, or a number used as index into the service list of CONN, :none to not generate code for services, or a string or symbol to look up the service by name in CONN)
  DESTINATION -- destination for the generated code (NIL to suppress output, or a stream, or T for *standard-output*, a pathname, or a string; if a string is specified it is used as basename for 3 files named destination-pkg.lisp, destination-types.lisp and destination-clos.lisp)

Keyword arguments: Read the source."
  (declare (ignore
	    object-access sequence message-method-prefix action object-class
	    compose port suffix prefix expand-singleton lisp-package service))
  (let ((comment-header  (generate-header-comment conn))
	(prelude-block   (etypecase prelude
			   (string (list prelude))
			   (function (funcall prelude))))
	(file-pkg-header `((defpackage ,(make-symbol file-package) 
			     (:use #:common-lisp #:cl-soap))
			   (in-package ,(make-symbol file-package))))
	(pkg-def-forms  (generate-pkg-defs conn))
	(symbol-export-forms (generate-symbol-exports conn))  ;; (uuh) FIXME: symbol mangling missing here
	(namespace-init-forms (generate-namespace-init-forms conn))
	)
    ;;; do the output:
    (when (eq T destination)
      (setf destination *standard-output*))
    (etypecase destination
      (stream
       ;; intro
       (shipout-comment comment-header destination)
       (terpri destination)
       ;; user prelude
       (shipout-forms prelude-block destination)
       ;; in-package form
       (shipout-forms file-pkg-header destination)
       (shipout-forms pkg-def-forms destination)
       ;; symbol exports
       (shipout-forms symbol-export-forms destination)
       ;; namespace initialization
       (shipout-forms namespace-init-forms destination)
       ;; ...
       
       
       ))
    
    ))


;;; code generators
(defun generate-header-comment (conn)
  "Generate a comment section to put into every generated code file."
  (format nil
	  (concatenate 'string
		       "-*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; package: cl-soap -*-~%"
		       "automatically generated by cl-soap on ~A~%"
		       "from ~A~%"
		       "~%")
	  (lisp->xsd-datetime (get-universal-time))
	  (or (get-documentation conn) conn)))

(defun generate-pkg-defs (conn)
  "Generate a list of forms that define the packages needed."
  ;; (uuh) FIXME: relies on the namespace environment found at call time (usually ok, but not a clean solution)
  (labels ((uri->defpkg-form (ns-uri)
	     `(defpackage 
	       ,(make-symbol (symbol-name (uri->pkgsym ns-uri)))
	       (:documentation ,(format nil "Package containing symbols for namespace uri <~A>" ns-uri)))))
    (cons (uri->defpkg-form +xsd2001-ns-uri+)
	  (loop :for schema :in (get-xml-schema-definitions conn)
		:for xmlns = (get-target-namespace schema)
		:collecting (uri->defpkg-form xmlns)))))

(defun generate-symbol-exports (conn)
  "Generate export forms for all schema types and elements."
  (labels ((all-exports-from-schema (schema)
	     "Extract all elements from SCHEMA."
	     (mapcar #'(lambda (elt)
			 (make-symbol (get-name elt)))
		     (get-elements schema))))
    (loop :for schema :in (get-xml-schema-definitions conn)
	  :for ns-pkg = (uri->pkgsym (get-target-namespace schema))
	  :collecting
	  `(defpackage ,(make-symbol (symbol-name ns-pkg)) 
	    (:export ,@(all-exports-from-schema schema))))))

(defun generate-namespace-init-forms (conn)
  (loop :for schema :in (get-xml-schema-definitions conn)
	:for uri = (get-target-namespace schema)
	:for ns = (s-xml:find-namespace uri)
	:collect (let ((prefix (s-xml:get-prefix ns))
		       (pkgsym (uri->pkgsym uri)))
		   `(s-xml:register-namespace ,uri ,prefix ,pkgsym))))


;;; utilities
(defun shipout-forms (forms stream)
  "Write the elements of the list FORMS on STREAM, nicely.
Strings in FORMS are written as comments.
Lists in FORMS are inspected for well-known cars: defpackage, defclass, defmethod and the like and pretty-printed accordingly."
  (loop :for elt :in forms 
	:if (stringp elt)
	:do (shipout-comment elt stream)
	:else :do (case (car elt)
		    ((defun defmethod defgeneric)
		     (shipout-defun elt stream))
		    ((defpackage)
		     (shipout-defpackage elt stream))
		    ((defclass)
		     (shipout-defclass elt stream))
		    (otherwise
		     (shipout-list elt stream)))
	:end
	:do (terpri stream)))

(defun shipout-comment (string stream)
  (pprint-logical-block (stream nil :per-line-prefix ";;; ")
   (format stream "~A" string)))

(defun shipout-defun (form stream)
  (format stream "~:<~W ~@_~:I~W ~:_~W~1I ~_~W~:>" form))

(defun shipout-defpackage (form stream)
  (destructuring-bind (defpkg pkgname &rest options)
      form
    (pprint-logical-block (stream form :prefix "(" :suffix ")")
      (write defpkg :stream stream)
      (write-char #\Space stream)
      (write pkgname :stream stream)
      (write-char #\Space stream)
      (pprint-newline :linear stream)
      (pprint-indent :current 1 stream)
      (loop :for option :in options 
	    :do (format stream "~<~@_~W~:>" options)))
    (terpri stream)))

(defun shipout-defclass (form stream)
  (shipout-defun form stream))

(defun shipout-list (form stream)
  (format stream "~W~%~%" form))

(defun uri->pkgsym (ns-uri)
  (intern (package-name (s-xml:get-package (s-xml:find-namespace ns-uri))) :keyword))